home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 4 / BBS in a Box - Macintosh - Volume IV (January 1992) (BBS in a Box).iso / Files / Prog / M / MCLUTILS.CPT / oodles-of-utils / brutal-utils / QuickDraw-u.lisp / QuickDraw-u.lisp
Encoding:
Text File  |  1991-10-23  |  11.1 KB  |  260 lines  |  [TEXT/CCL2]
  1. (in-package :oou)
  2. (provide :QuickDraw-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; QuickDraw-u.lisp
  5. ;;
  6. ;; Copyright © 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; utilities for quickdraw
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :records-u)
  16.  
  17. (export '( with-pen-state
  18.            with-text-state with-font-spec
  19.            with-back-pat with-back-pix-pat
  20.            with-clip-rgn
  21.            color-graf-port-p
  22.            move-region-to
  23.            frame-rect-3D
  24.            ))
  25.  
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. #|
  28.  
  29. The various with-??? macros assume the body code doesn't change the
  30. current port (or at least restores it).
  31.  
  32. |#
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34. ;;; macros
  35.  
  36. (eval-when (:compile-toplevel :load-toplevel :execute)
  37.   
  38.   (defmacro with-pen-state ((&key pnLoc pnSize pnMode pnPat pnPixPat) &body body)
  39.     (let ((state (gensym)))
  40.       `(rlet ((,state :PenState))
  41.          (require-trap #_GetPenState ,state)
  42.          (unwind-protect
  43.            (progn
  44.              ,@(when pnLoc    `((require-trap #_MoveTo (point-h ,pnLoc) (point-v ,pnLoc))))
  45.              ,@(when pnSize   `((require-trap #_PenSize (point-h ,pnSize) (point-v ,pnSize))))
  46.              ,@(when pnMode   `((require-trap #_PenMode ,pnMode)))
  47.              ,@(when pnPat    `((require-trap #_PenPat ,pnPat)))
  48.              ,@(when pnPixPat `((require-trap #_PenPixPat ,pnPixPat)))
  49.              ,@body)
  50.            (require-trap #_SetPenState ,state)))))
  51.  
  52.   ;;;;;;;;;;
  53.   ;;font macros
  54.  
  55.   (defmacro with-text-state ((&key txFont txFace txMode txSize) &body body)
  56.     (let ((thePort (gensym))
  57.           (old-font (gensym))
  58.           (old-face (gensym))
  59.           (old-mode (gensym))
  60.           (old-size (gensym)))
  61.       `(with-macptrs ((,thePort (%getport)))
  62.          (let(,@(when txFont `((,old-font (pref ,thePort :GrafPort.txFont))))
  63.               ,@(when txFace `((,old-face (pref ,thePort :GrafPort.txFace))))
  64.               ,@(when txMode `((,old-mode (pref ,thePort :GrafPort.txMode))))
  65.               ,@(when txSize `((,old-size (pref ,thePort :GrafPort.txSize)))))
  66.              (unwind-protect
  67.                (progn
  68.                  ,@(when txFont `((require-trap #_TextFont ,txFont)))
  69.                  ,@(when txFace `((require-trap #_TextFace ,txFace)))
  70.                  ,@(when txMode `((require-trap #_TextMode ,txMode)))
  71.                  ,@(when txSize `((require-trap #_TextSize ,txSize)))
  72.                  ,@body)
  73.                ,@(when txFont `((require-trap #_TextFont ,old-font)))
  74.                ,@(when txFace `((require-trap #_TextFace ,old-face)))
  75.                ,@(when txMode `((require-trap #_TextMode ,old-mode)))
  76.                ,@(when txSize `((require-trap #_TextSize ,old-size))))))))
  77.  
  78.   (defmacro with-font-spec (font-spec &body body)
  79.     (if (and (listp font-spec) (every #'constantp font-spec))
  80.       (multiple-value-bind (ff ms) (font-codes font-spec)
  81.         `(with-font-codes ,ff ,ms ,@body))
  82.       (let ((ff (gensym))
  83.             (ms (gensym)))
  84.         `(multiple-value-bind (,ff ,ms) (font-codes ,font-spec)
  85.            (with-font-codes ,ff ,ms ,@body)))))
  86.  
  87.   ;;;;;;;;;;
  88.   ;; BackPat macros
  89.   ;; Note: these both work with GrafPort's AND CGrafPort's
  90.   
  91.   (defmacro with-back-pat (pattern &body body)
  92.     (let ((fn (gensym)))
  93.       `(flet ((,fn () (require-trap #_BackPat ,pattern) ,@body))
  94.          (declare (dynamic-extent #',fn))
  95.          (call-with-back-pat-saved #',fn))))
  96.  
  97.   (defmacro with-back-pix-pat (pix-pat &body body)
  98.     (let ((fn (gensym)))
  99.       `(flet ((,fn () (require-trap #_BackPixPat ,pix-pat) ,@body))
  100.          (declare (dynamic-extent #',fn))
  101.          (call-with-back-pat-saved #',fn))))
  102.  
  103.   ;;;;;;;;;;
  104.   ;;clip macros
  105.   
  106.   (defmacro with-clip-rgn (clip-rgn &body body)
  107.     (let ((old-clip (gensym)))
  108.       `(with-macptrs ((,old-clip (require-trap #_NewRgn)))
  109.          (unwind-protect
  110.            (progn
  111.              (require-trap #_GetClip ,old-clip)
  112.              (require-trap #_SetClip ,clip-rgn)
  113.              ,@body)
  114.            (require-trap #_SetClip ,old-clip)
  115.            (require-trap #_DisposeRgn ,old-clip)))))
  116.  
  117.   ;;;;;;;;;;
  118.   ;;QDProc macro
  119.   ;; Note: these both work with GrafPort's AND CGrafPort's
  120.  
  121.   (defmacro with-QDProcs ((&key textProc lineProc rectProc rRectProc ovalProc arcProc polyProc
  122.                                 rgnProc bitsProc commentProc txMeasProc getPicProc putPicProc
  123.                                 opCodeProc newProc1 newProc2 newProc3 newProc4 newProc5 newProc6
  124.                                 )
  125.                           &body body)
  126.     ;;GrafPorts & CGrafPorts are handled identically! This works because:
  127.     ;; - the first 13 fields of a CQDProc are a QDProc
  128.     ;; - both GrafPorts & CGrafPorts use the same stdProcs for these 13 fields.     
  129.     (let ((thePort (gensym))
  130.           (old-procs (gensym))
  131.           (new-procs (gensym)))
  132.       `(with-macptrs ((,thePort (%getport))
  133.                       (,old-procs (pref ,thePort :GrafPort.grafProcs)))
  134.          (rlet ((,new-procs :CQDProcs))
  135.            (if (%null-ptr-p ,old-procs)
  136.              (require-trap #_SetStdCProcs ,new-procs)
  137.              (require-trap #_BlockMove ,old-procs ,new-procs (rlength :CQDProcs)))
  138.            ,@(when textProc    `((pset ,new-procs :CQDProcs.textProc    ,textProc   )))
  139.            ,@(when lineProc    `((pset ,new-procs :CQDProcs.lineProc    ,lineProc   )))
  140.            ,@(when rectProc    `((pset ,new-procs :CQDProcs.rectProc    ,rectProc   )))
  141.            ,@(when rRectProc   `((pset ,new-procs :CQDProcs.rRectProc   ,rRectProc  )))
  142.            ,@(when ovalProc    `((pset ,new-procs :CQDProcs.textProc    ,ovalProc   )))             
  143.            ,@(when arcProc     `((pset ,new-procs :CQDProcs.arcProc     ,arcProc    )))
  144.            ,@(when polyProc    `((pset ,new-procs :CQDProcs.polyProc    ,polyProc   )))
  145.            ,@(when rgnProc     `((pset ,new-procs :CQDProcs.rgnProc     ,rgnProc    )))
  146.            ,@(when bitsProc    `((pset ,new-procs :CQDProcs.bitsProc    ,bitsProc   )))
  147.            ,@(when commentProc `((pset ,new-procs :CQDProcs.commentProc ,commentProc)))
  148.            ,@(when txMeasProc  `((pset ,new-procs :CQDProcs.txMeasProc  ,txMeasProc )))
  149.            ,@(when getPicProc  `((pset ,new-procs :CQDProcs.getPicProc  ,getPicProc )))
  150.            ,@(when putPicProc  `((pset ,new-procs :CQDProcs.putPicProc  ,putPicProc )))
  151.            ,@(when opCodeProc  `((pset ,new-procs :CQDProcs.opCodeProc  ,opCodeProc )))
  152.            ,@(when newProc1    `((pset ,new-procs :CQDProcs.newProc1    ,newProc1   )))
  153.            ,@(when newProc2    `((pset ,new-procs :CQDProcs.newProc2    ,newProc2   )))
  154.            ,@(when newProc3    `((pset ,new-procs :CQDProcs.newProc3    ,newProc3   )))
  155.            ,@(when newProc4    `((pset ,new-procs :CQDProcs.newProc4    ,newProc4   )))
  156.            ,@(when newProc5    `((pset ,new-procs :CQDProcs.newProc5    ,newProc5   )))
  157.            ,@(when newProc6    `((pset ,new-procs :CQDProcs.newProc6    ,newProc6   )))
  158.            (unwind-protect
  159.              (progn
  160.                (pset ,thePort :CGrafPort.grafProcs ,new-procs)
  161.                ,@body)
  162.              (pset ,thePort :CGrafPort.grafProcs ,old-procs))))))
  163.   
  164.   )
  165.  
  166.  
  167. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  168.  
  169. (defun truncate-pstr (pstr max-width)
  170.   "pstr max-width
  171. If the string is longer than max-width it's destructively truncated +
  172. the last char replaced with '…'. (lengths based on the current font)"
  173.   (let ((len (%get-unsigned-byte pstr)))
  174.     (%stack-block ((wTable (* 2 len)))
  175.       (#_MeasureText len pstr wTable)
  176.       (with-macptrs ((end (%inc-ptr wTable (* 2 len))))
  177.         (unless (<= (%get-unsigned-word end) max-width)
  178.           (decf max-width (#_CharWidth #\…))
  179.           (if (plusp max-width)
  180.             (loop
  181.               (when (<= (%get-unsigned-word (%incf-ptr end -2)) max-width)
  182.                 (%put-byte pstr len)
  183.                 (%put-byte pstr #.(char-code #\…) len)
  184.                 (return))
  185.               (decf len))
  186.             (%put-byte pstr 0))))))
  187.   pstr)
  188.  
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190.  
  191. (defun call-with-back-pat-saved (fn)
  192.   (with-macptrs ((thePort (%getport)))
  193.     (let ((pat-type 0))
  194.       (declare (dynamic-extent pat-type))
  195.       (rlet ((old-pat :Pattern))
  196.         (if (color-port-p thePort)
  197.           (with-dereferenced-handles ((ppat_p (pref thePort :CGrafPort.bkPixPat)))
  198.             (setf pat-type (pref ppat_p PixPat.patType))
  199.             (if (zerop pat-type)
  200.               (with-dereferenced-handles ((data_p (pref ppat_p PixPat.patData)))
  201.                 (#_BlockMove data_p old-pat (rlength :Pattern)))
  202.               (%setf-macptr old-pat (pref thePort :CGrafPort.bkPixPat))))
  203.           (#_BlockMove (pref thePort :GrafPort.bkPat) old-pat (rlength :Pattern)))
  204.         (unwind-protect
  205.           (funcall fn)
  206.           (if (zerop pat-type)
  207.             (#_BackPat old-pat)
  208.             (#_BackPixPat old-pat)))))))
  209.  
  210. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  211.  
  212. (defun color-port-p (grafPtr)
  213.   (logbitp 15 (pref grafPtr :GrafPort.portBits.rowBytes)))
  214.  
  215. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  216.  
  217. (defun move-region-to (rgn-handle h &optional v)
  218.   (let* ((delta (make-point h v))
  219.          (dh (point-h delta))
  220.          (dv (point-v delta)))
  221.     (#_OffsetRgn rgn-handle (- dh (href rgn-handle :Region.rgnBBox.left))
  222.                             (- dv (href rgn-handle :Region.rgnBBox.top )))))
  223.  
  224. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  225.  
  226. ;;Mac human interface guidlines specify that the light source is in the
  227. ;;upper-left corner. Hence and botRight shadow gives a "popped out" look
  228. ;;and a topLeft shadow gives a "pushed in" look.
  229.  
  230. (defun frame-rect-3D (rect frame-width shadow-position)
  231.   "r frame-width shadow-position
  232. Frame's the specified Rect with a 3D look.
  233. Note: this effect only looks right over grayish backgrounds."
  234.     (let* ((%top   (pref rect :Rect.top   ))
  235.            (%left  (pref rect :Rect.left  ))
  236.            (%bot   (pref rect :Rect.bottom))
  237.            (%right (pref rect :Rect.right )))
  238.       (with-pen-state (:pnSize (make-point frame-width frame-width)
  239.                                :pnMode #$patCopy
  240.                                :pnLoc (make-point %left (- %bot frame-width)))       
  241.         ;;left & top edges
  242.         (#_PenPat (ecase shadow-position (:topLeft *black-pattern*) (:botRight *white-pattern*)))
  243.         (#_LineTo %left %top)
  244.         (#_LineTo (- %right frame-width) %top)
  245.         
  246.         ;;right & bottom edges
  247.         (#_PenPat (ecase shadow-position (:topLeft *white-pattern*) (:botRight *black-pattern*)))
  248.         (#_LineTo (- %right frame-width) (- %bot frame-width))
  249.         (#_LineTo %left (- %bot frame-width))
  250.         
  251.         ;;topRight & botLeft corners
  252.         (#_PenPat (ecase shadow-position (:topLeft *black-pattern*) (:botRight *white-pattern*)))
  253.         (#_PenSize 1 1)
  254.         (#_MoveTo (- %right frame-width) (+ %top frame-width -2))
  255.         (dotimes (i frame-width) (#_Line i 0) (#_Move (- i) -1))
  256.         (#_MoveTo %left (1- %bot))
  257.         (dotimes (i frame-width) (#_Line i 0) (#_Move (- i) -1)))))
  258.  
  259. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  260.